home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #2 / Monster Media No. 2 (Monster Media)(1994).ISO / prog_gen / janusw.zip / DEBUG.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-16  |  3KB  |  156 lines
  1. {$A+,B-,G+,I-,O-,P+,Q-,R-,S-,T-,V-,X+}
  2. Unit Debug;
  3. { Unit:      Debug
  4.   Version:   1.00
  5.   Purpose:   useful functions for debug output
  6.   Uses:      DbWin or monochrome monitor as output device
  7.   Date:      01/21/94
  8.  
  9.   Developer: Peter Sawatzki (ps)
  10.              Buchenhof 3, 58091 Hagen, Germany
  11.  CompuServe: 100031,3002
  12.  
  13.   Date:    Author:
  14.   08/01/93 ps     wrote it
  15.   01/18/94 ps/jwp correct bug in debugoutput, add R- option
  16.   01/21/94 ps     minor 'optimizations'
  17.  
  18.   Copyright (c) 1994 Peter Sawatzki. All Rights Reserved.
  19.  
  20. }
  21. Interface
  22. Uses
  23.   WinTypes,
  24.   WinProcs,
  25.   WinDos,
  26.   Strings;
  27. Type
  28.   Str2 = String[2];
  29.   Str4 = String[4];
  30.   Str8 = String[8];
  31.   Str10 = String[10];
  32.   PtrRec = Record
  33.              Ofs, Seg: Word
  34.            End;
  35.   LongRec = Record
  36.               LoWord, HiWord: Word
  37.             End;
  38.  
  39. Procedure BreakPoint; Inline($CC);
  40. Function HexB (b: Byte): Str2;
  41. Function HexW (w: Word): Str4;
  42. Function HexL (l: LongInt): Str8;
  43. Function L2S (l: LongInt): Str10;
  44. Function W2S (w: Word): Str10;
  45. Function StrPasEx(Str: pChar): String;
  46.  
  47. Procedure AssignDebug (Var F: Text);
  48.  
  49. Implementation
  50. Const
  51.   HC: Array[0..$F] Of Char = '0123456789ABCDEF';
  52.  
  53. Function HexB (b: Byte): Str2;
  54. Begin
  55.   HexB[0]:= #2;
  56.   HexB[1]:= HC[b Shr 4];
  57.   HexB[2]:= HC[b And $F]
  58. End;
  59.  
  60. Function HexW (w: Word): Str4;
  61. Begin
  62.   HexW[0]:= #4;
  63.   HexW[1]:= HC[w Shr 12];
  64.   HexW[2]:= HC[Hi(w) And $F];
  65.   HexW[3]:= HC[Lo(w) Shr 4];
  66.   HexW[4]:= HC[w And $F]
  67. End;
  68.  
  69. Function HexL (l: LongInt): Str8;
  70. Begin With LongRec(l) Do Begin
  71.   HexL[0]:= #8;
  72.   HexL[1]:= HC[HiWord Shr 12];
  73.   HexL[2]:= HC[Hi(HiWord) And $F];
  74.   HexL[3]:= HC[Lo(HiWord) Shr 4];
  75.   HexL[4]:= HC[HiWord And $F];
  76.   HexL[5]:= HC[LoWord Shr 12];
  77.   HexL[6]:= HC[Hi(LoWord) And $F];
  78.   HexL[7]:= HC[Lo(LoWord) Shr 4];
  79.   HexL[8]:= HC[LoWord And $F]
  80. End End;
  81.  
  82. Function L2S (l: LongInt): Str10;
  83. Var
  84.   pStr: ^Str10;
  85. Begin
  86.   Asm Les Di, @Result; Mov Word(pStr), Di; Mov Word(pStr+2), Es End;
  87.   Str(l,pStr^)
  88. End;
  89.  
  90. Function W2S (w: Word): Str10;
  91. Var
  92.   pStr: ^Str10;
  93. Begin
  94.   Asm Les Di, @Result; Mov Word(pStr), Di; Mov Word(pStr+2), Es End;
  95.   Str(w,pStr^)
  96. End;
  97.  
  98. Function StrPasEx(Str: pChar): String;
  99. Begin
  100.   If PtrRec(Str).Seg=0 Then
  101.     StrPasEx:= '#'+L2S(Word(Str))
  102.   Else
  103.     StrPasEx:= StrPas(Str)
  104. End;
  105.  
  106. {------------------------------------------ Debug output functions }
  107.  
  108. Function DebugOutput (Var F: tTextRec): Integer; Far;
  109. Var
  110.   TwoCh: Array[0..1] Of Char;
  111. Begin
  112.   With F Do If BufPos>0 Then Begin
  113.     TwoCh[0]:= #0; TwoCh[1]:= #0;
  114.     If BufPos=BufSize Then Begin
  115.       Dec(BufPos);
  116.       TwoCh[0]:= BufPtr^[BufPos]
  117.     End;
  118.     BufPtr^[BufPos]:= #0;
  119.     OutputDebugString(pChar(BufPtr));
  120.     If TwoCh[0]<>#0 Then
  121.       OutputDebugString(TwoCh);
  122.     BufPos:= 0
  123.   End;
  124.   DebugOutput:= 0
  125. End;
  126.  
  127. Function DebugClose (Var F: tTextRec): Integer; Far;
  128. Begin
  129.   DebugClose:= 0
  130. End;
  131.  
  132. Function DebugOpen (Var F: tTextRec): Integer; Far;
  133. Begin With F Do Begin
  134.   Mode:= fmOutput;
  135.   InOutFunc:= @DebugOutput;
  136.   FlushFunc:= @DebugOutput;
  137.   CloseFunc:= @DebugClose;
  138.   DebugOpen:= 0
  139. End End;
  140.  
  141. Procedure AssignDebug (Var F: Text);
  142. Begin With tTextRec(F) Do Begin
  143.   Handle:= $FFFF;
  144.   Mode:= fmClosed;
  145.   BufSize:= SizeOf(Buffer);
  146.   BufPtr:= @Buffer;
  147.   OpenFunc:= @DebugOpen;
  148.   Name[0]:= #0
  149. End End;
  150.  
  151. Begin
  152.   AssignDebug(Output);
  153.   Rewrite(Output)
  154. End.
  155.  
  156.